{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Behavior
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Time varying behaviors.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.Behavior
  (
    Behavior
  , runBehavior
  , applyBeh
  , constB
  , liftB1
  , liftB2
  , liftB3

  , timeB
  , condB
  , (==*)
  , (/=*)
  , compareB
  , (<*)
  , (>*)
  , (<=*)
  , (>=*)

  , timeTrans
  , ramp

  ) where

import Majalan.Base.Internal.Base

import Control.Applicative hiding ( (<*) )
import Data.Monoid

--------------------------------------------------------------------------------
-- Behaviors (model time changing values c.f envelopes)

newtype Behavior a = Beh { getBeh :: Seconds -> a } 


runBehavior :: Behavior a -> (Seconds -> a)
runBehavior = getBeh

instance Functor Behavior where
  fmap f bf = Beh $ \t -> let a = getBeh bf t in f a

instance Applicative Behavior where
  pure      = constB
  mf <*> ma = Beh $ \t -> let f = getBeh mf t
                              a = getBeh ma t
                          in f a


applyBeh :: Behavior a -> Seconds -> a
applyBeh b start = getBeh b start

constB :: a -> Behavior a
constB x = Beh $ \_ -> x

liftB1 :: (a -> ans) -> Behavior a -> Behavior ans
liftB1 f bf = Beh $ \t -> f (getBeh bf t)

liftB2 :: (a -> b -> ans) -> Behavior a -> Behavior b -> Behavior ans
liftB2 f bf bg = Beh $ \t -> f (getBeh bf t) (getBeh bg t)

liftB3 :: (a -> b -> c -> ans) -> Behavior a -> Behavior b -> Behavior c 
       -> Behavior ans
liftB3 f bf bg bh = Beh $ \t -> f (getBeh bf t) (getBeh bg t) (getBeh bh t)


instance Monoid a => Monoid (Behavior a) where
  mempty  = constB mempty
  mappend = liftB2 mappend

instance Num a => Num (Behavior a) where
  (+)           = liftB2 (+)
  (-)           = liftB2 (-)
  (*)           = liftB2 (*)
  negate        = liftB1 negate
  abs           = liftB1 abs
  signum        = liftB1 signum
  fromInteger   = constB . fromInteger

instance Fractional a => Fractional (Behavior a) where
  (/)           = liftB2 (/)
  fromRational  = constB . fromRational

instance Floating a => Floating (Behavior a) where
  pi            = constB pi
  sqrt          = liftB1 sqrt
  exp           = liftB1 exp
  log           = liftB1 log
  sin           = liftB1 sin
  cos           = liftB1 cos
  tan           = liftB1 tan
  asin          = liftB1 asin
  acos          = liftB1 acos
  atan          = liftB1 atan
  sinh          = liftB1 sinh
  cosh          = liftB1 cosh
  tanh          = liftB1 tanh
  asinh         = liftB1 asinh
  acosh         = liftB1 acosh
  atanh         = liftB1 atanh


timeB :: Behavior Seconds
timeB = Beh $ id


condB :: Behavior Bool -> Behavior a -> Behavior a -> Behavior a
condB = liftB3 $ \test tc fc -> if test then tc else fc


infix 4 ==*

(==*) :: Eq a => Behavior a -> Behavior a -> Behavior Bool
(==*) = liftB2 (==)

infix 4 /=*

(/=*) :: Eq a => Behavior a -> Behavior a -> Behavior Bool
(/=*) = liftB2 (/=)


compareB :: Ord a => Behavior a -> Behavior a -> Behavior Ordering
compareB = liftB2 compare

infix 4 <*

(<*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(<*) = liftB2 (<)

infix 4 >*

(>*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>*) = liftB2 (>)

infix 4 <=*

(<=*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(<=*) = liftB2 (<=)

infix 4 >=*

(>=*) :: Ord a => Behavior a -> Behavior a -> Behavior Bool
(>=*) = liftB2 (>=)


timeTrans :: Behavior Seconds -> Behavior a -> Behavior a
timeTrans bf bg = Beh $ \t -> getBeh bg (getBeh bf t)

ramp :: Seconds -> Seconds -> Seconds -> Behavior Seconds
ramp lo drn hi = Beh $ \t -> 
    if t < drn then let frac = t/drn; delta = (hi - lo) * frac in lo + delta
               else hi